perm filename MAINPR.SAI[PNT,HE]10 blob
sn#373809 filedate 1978-08-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00028 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 initial declarations and global variables
C00005 00003 ! facilities: error messages,syntax explanations,error,abort1
C00011 00004 ! parsing procedures
C00012 00005 ! display, input/output procedures
C00015 00006 ! display, input/output procedures - UPDATE, ARROW, Readcode
C00020 00007 ! symbol table: check,checktot,ensym,delsym,newsym,oldsym,addsymused,delsymused,delsymref
C00029 00008 ! symbol table: mk_fn, mk_rec
C00033 00009 ! symbol table: nwr,new_sc,new_vt,new_rt,new_tr,new_fr,dcdsym
C00035 00010 ! symbol table: control,insertion
C00041 00011 ! symbol table: killtree,killvar,reset
C00048 00012 ! assignment instruction
C00050 00013 ! tree operations: affixcode,unfixcode (afx_node)
C00054 00014 ! tree operations: copycode,copy,copy_tree
C00059 00015 ! arm interactions: read_pos,readarm,frasg
C00063 00016 ! arm interactions: arm_check,goarm,movefrfr
C00066 00017 ! arm interactions: mvfrcode,mvfrexp
C00068 00018 ! arm interactions: centercode,closecode,opencode,fconstructproc
C00074 00019 ! system facilities: editcode,renmcode
C00080 00020 ! parse procedures: affixproc,bailcall,defineproc,promptproc
C00087 00021 ! parse procedures: centerproc,opclproc,constread,copyproc
C00094 00022 ! parse procedures: declproc,deleteproc,driveproc,editproc,printproc,exitproc,explass,freeproc
C00105 00023 ! parse procedures: vtrtpart,moveproc,axmovproc
C00109 00024 ! parse procedures: other, readwristproc
C00114 00025 ! parse procedures: parking,readproc,renmproc,writeproc,unfixproc
C00117 00026 ! parse procedures :notavailproc,displayproc,nodisplayproc,readlisp,stoplispproc
C00120 00027 ! parse
C00129 00028 ! main program
C00132 ENDMK
C⊗;
comment initial declarations and global variables;
DEFINE $MAINPR=TRUE ;
REQUIRE 300 STRING_PDL;REQUIRE 1000 SYSTEM_PDL;
REQUIRE 10000 STRING_SPACE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
IFC #DEBUG THENC
REQUIRE "PRINTX.HDR[AL,HE]" SOURCE_FILE;
! FOR PRINTING OUT RECORDS ;
! BAIL BUG REQUIRES FOLLOWING DUMMY PROCEDURE;
PROCEDURE BAIL_ANAMOLY;
BEGIN PRINTX(3); RECPRN(F_WRLD);TBLKSUPPRESS(NULL);SETRPM(0,0); END;
ENDC
LABEL MAINL; ! used by abort procedures to go to the top level;
LABEL DONEPOINTY; ! used to exit;
! facilities: error messages,syntax explanations,error,abort1;
INTEGER $HELP; ! used by error;
! error messages for syntactic errors;
PRESET_WITH
"--→ ; ",
"--→ , ",
"--→ . ",
"--→ [ ",
"--→ ] ",
"--→ ( ",
"--→ ) ",
"--→ + ",
"--→ * ",
"--→ ALONG ",
"--→ BY ",
"--→ INTO ",
"--→ REL ",
"--→ ROT ",
"--→ TO ",
"--→ TRANS ",
"--→ WRT ",
"--→ XHAT or YHAT or ZHAT ",
"--→ YARM or BARM ",
"--→ YHAND or BHAND ",
"--→ INPUT after ↑, ↓, ∨, ∧, <, >",
"--→ identifier ",
"--→ number ",
"--→ file name ",
"--→ arithmetic operator ",
"required ←--",
"--→ error in explicit ",
"vector ←--",
"rotation ←--",
"frame ←--",
"--→ affix_type is wrong ←--",
"--→ wrong identifier or wrong number ←--",
"--→ unrecognized instruction ←--",
"| ",
"VECTOR required after DISTANCE",
"--→ undeclared identifier ";
INTERNAL STRING ARRAY $SYNMSG[0:35];
! error messages used for semantic errors;
! the first messages cannot be moved in another position because they
are referred to using the type of the variables(#SC,#VT,#RT,@TR,@FR);
PRESET_WITH
" scalar not existent ",
" vector not existent ",
" rotation not existent ",
" trans not existent ",
" frame not existent ",
" is not scalar nor vector nor rotation ",
" object not existent ",
" out of symbol table, delete some variables and try again",
" cannot be moved ",
" already defined symbol ",
" dismatching of types ",
" affixed frame ",
" reading on arm required ",
" instruction not executed",
" is a POINTY defined variable or constant and cannot be changed";
INTERNAL STRING ARRAY $SEMSG[0:14];
INTERNAL simple procedure esc_I;
$esc_I←true;
INTERNAL PROCEDURE ESC_P;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000120]; comment [004000,,"P"];
ttyset 1, ; ! this last stuff does an esc-P;
end;
END;
PROCEDURE BRK_N;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000516]; comment [004000,,400+"N"];
ttyset 1, ; ! this last stuff does an BRK-N;
end;
END;
! called after syntax error. If required gives explanation of the error;
INTERNAL PROCEDURE ERROR(STRING ERR1,ERR2(NULL));
BEGIN
STRING ANSWER;
PRINT (ERR1,ERR2,CRLF);
PRINT(" ",TOKEN," ",$CLINR,IFC #HELP THENC "(? for more explanation)"
ELSEC CRLF ENDC);
IFC #HELP THENC
ANSWER←INCHRW;IF ANSWER=CR THEN INCHRW;
OUTSTR(CRLF);
IF ANSWER="?" THEN HLPMSG($HELP); ! if required gives explanations;
ENDC
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
! *** PRINT("* ");ESC_P;
LODED($CLNE&CR); ! so it is possible to correct the command;
$CLINR←NULL; STOKEN←FALSE;
GO TO MAINL; ! goes to the main loop;
END;
! called after unrecoverable semantic error;
INTERNAL PROCEDURE ABORT1(STRING NAME,ERROR(NULL));
BEGIN
PRINT (NAME,ERROR,CRLF);
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
! *** PRINT("* ");ESC_P;
LODED($CLNE&CR); ! so it is possible to correct the command;
$CLINR←NULL; STOKEN←FALSE;
GO TO MAINL; ! goes to the main loop;
END;
! parsing procedures;
! INTERNAL STRING OLDOBJ; ! used for defaults;
STRING OLDCMD; ! used for defaults;
! saves important parts of last instruction, for default instructions.
Oldobj is used to pass to gettoken the value corresponding to the ⊗;
SIMPLE PROCEDURE OLDSAV(STRING CMD,OBJ);
BEGIN
OLDCMD←CMD;
OLDOBJ←OBJ;
END;
! display, input/output procedures;
! called when an indefined variable is used. Tries to recover, asking
the correct name of the variable, and returns it.
(null string or <control-C> to return to the main loop);
STRING PROCEDURE RECOVER(STRING SYMB);
BEGIN "R"
STRING ANSWER;LABEL CC;
! you can change the identifier symb;
CC:
LODED(SYMB&CR);
ANSWER←INCHWL; ! reads new identifier;
IFC #OUTPT THENC
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
ENDC
SYMB←SCAN(ANSWER,$ERRTAB,$BRCHR); ! eliminates blanks and checks break;
IF $BRCHR≠0 AND $BRCHR≠'40
THEN BEGIN
PRINT("break character found. Try again ");
GO TO CC; ! so... you can try again;
END
ELSE IF SYMB THEN RETURN(SYMB); ! a "good" symbol is returned;
! you want to delete the instruction being interpreted;
CLRBUF;
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END "R";
IFC #OUTPT THENC
! allows recovering if a file not available has been required
(null string or <control-C> to return to the main loop);
INTERNAL STRING PROCEDURE FRCVER(STRING FILE);
BEGIN "F"
LODED(FILE&CR);
ASKUSER;
IFC #OUTPT THENC
IF $OUT THEN CPRINT($TTYCH,$CLINR,CRLF);
ENDC
IF $CLINR
THEN RETURN(NAMEFILE)
ELSE BEGIN
CLRBUF;
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END;
END "F";
ENDC
! display, input/output procedures - UPDATE, ARROW, Readcode;
IFC ¬ #ARROW THENC
INTERNAL SIMPLE PROCEDURE ARROW; ;
ENDC
IFC #DISPL THENC
INTEGER TDISPLAY;
BOOLEAN NDISPLAY;
PROCEDURE DPYVAR(INTEGER VARTYPE);
IF VARTYPE<0 THEN
BEGIN IF NDISPLAY THEN RETURN;
OUTDPW(
"**************************** P O I N T Y **********************************
DISPLAY SUPPRESSED; TYPE REDISPLAY TO GET BACK DISPLAY TABLE
TYPE DISPLAY SCALARS TO DISPLAY SCALARS
****************************************************************************
",-3,-2); NDISPLAY←TRUE;
END ELSE
IF NOT $DISPLAYLIST[VARTYPE] THEN
OUTDPW(
("************************* CURRENT "&$DTYPE[VARTYPE]&"S ***********************************************")
[1 TO 74]&crlf&($DISPLAYLIST[VARTYPE]←DPY_STRING(VARTYPE))&
"***************************************************************************"
,-3,-3);
SIMPLE STRING PROCEDURE DEFAULT;
RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);
! update the display (if $ALLOW=0);
INTERNAL PROCEDURE UPDATE;
BEGIN INTEGER I;
IF $ALLOW>0 THEN RETURN;
IF TDISPLAY THEN BEGIN DPYVAR(TDISPLAY); ESC_P; RETURN; END;
NDISPLAY←FALSE;
DPYDRAW;
FOR I←#SC,#VT,#TR,#RT,#FR DO
IF NOT $DISPLAYLIST[I] THEN $DISPLAYLIST[I]←DPY_STRING(I);
IFC #OUTPT THENC IF NOT $OULST THEN $OULST←FILE_STRING;ENDC
$DFLST←DEFAULT;
OUTDPY;
DPYOUT(1);ESC_P;
END;
ENDC
IFC #OUTPT THENC
! these procedures used to read from a file are here and not in
the input/output module becuase the READEXEC procedure calls
the PARSE procedure for each instruction;
! the above comment is no longer true, since READEXEC no longer
exists. However, they should be shifted to the input/output module
when some rational means to keep track of I/0 is settled upon.
I think what is wanted is a file record that it used to keep
all the information related to each file ;
PROCEDURE READCODE(STRING FID; BOOLEAN ECHO);
BEGIN
PUSHDEVSTACK;
OPEN($INPCH←GETCHAN,"DSK",0,3,0,1000,$BRCHR,$EOF);
LOOKUP($INPCH,FID,$EOF);
WHILE $EOF
DO BEGIN
PRINT("enter failed");
FID←FRCVER(FID);
LOOKUP($INPCH,FID,$EOF);
END;
IFC #DISPL THENC $ALLOW←$ALLOW+1; IF ECHO THEN DPYFREE; $SCLST←NULL; ! to force update; ENDC
DEVICE←DSK_X;
NEWFILE←TRUE; FILEPRINT←ECHO;
END;
CLEANUP FCLOSE;
ELSEC
INTERNAL PROCEDURE UPDATE;;
ENDC
! called after reading ?. Gives some information, erasing the display;
IFC #HELP THENC
SIMPLE PROCEDURE HELPREQUEST;
BEGIN "H"
IFC #DISPL THENC DPYFREE;ENDC
! reads the comand after ?, if there is;
! $TAIL←SCAN($LINE,$SCNTAB,$BRCHR);
! HLPDO($TAIL); ! in HELP.SAI[1,MLG];
ASKUSER;
HLPDO($clinr);
$clinr←$clne←null;
IFC #DISPL THENC UPDATE;ENDC
END "H";
ENDC
! symbol table: check,checktot,ensym,delsym,newsym,oldsym,addsymused,delsymused,delsymref;
! checks if symbol symb, of type nm, is in symbol table in the class nm,
and return its pointer;
INTERNAL RPTR(SYMBOL) PROCEDURE CHECK(STRING SYMB;INTEGER NM);
BEGIN
RPTR(SYMBOL) TEMP;INTEGER IND,I;
IND←$ENTRY[NM]-1; ! address of last record of type nm filled;
FOR I← (NM-#MIN)*#LTYPE STEP 1 UNTIL IND DO
BEGIN
TEMP←$YMTAB[I];
IF TEMP≠NULL_RECORD
THEN IF EQU(SYMBOL:PNAME[TEMP],SYMB)
THEN BEGIN
RETURN(TEMP);
END;
END;
RETURN(NULL_RECORD); ! symbol not found;
END;
! checks if symbol symb is in symbol table, determines its class and
return its pointer;
INTERNAL RPTR(SYMBOL) PROCEDURE CHECKTOT(STRING SYMB;REFERENCE INTEGER NM);
BEGIN
INTEGER IND,I,K;RPTR(SYMBOL)TEMP;
FOR K←#MIN STEP 1 UNTIL #MAX DO
BEGIN
TEMP←CHECK(SYMB,K);
IF TEMP≠NULL_RECORD
THEN BEGIN
NM←K; ! changes the value of REFERENCE variable;
RETURN(TEMP);
END;
END;
RETURN(NULL_RECORD); ! symbol not found;
END;
! enters the symbol symb and the pointer to its node in symbol table,
in the class nm. The record of the class SCALAR,VECTOR,ROT,TRANS or
FRAME has to be constructedbefore calling ENSYM;
INTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL);
BEGIN
RPTR (SYMBOL) TEMP;INTEGER IND;
IND←$ENTRY[NM]; ! address of last record of type nm filled;
IF IND≥(NM+1-#MIN)*#LTYPE
THEN ABORT1($SEMSG[7]); ! out of symbol table;
TEMP←NEW_RECORD(SYMBOL);
$YMTAB[IND]←TEMP; ! pointer to the new record in $YMTAB;
SYMBOL:VALID[TEMP]←TRUE;
$ENTRY[NM]←IND+1; ! updating of $ENTRY;
SYMBOL:PNAME[TEMP]←SYMB; ! pname of symbol;
SYMBOL:OBJECT[TEMP]←VAL; ! pointer to the record previously created;
RETURN(TEMP);
END;
! returns a new symbol, if symb is present in $YMTAB. Id used before
inserting a new symbol in $YMTAB to be sure that a symbol with the
name has not been defined before. This procedure allows recovering;
STRING PROCEDURE NEWSYM(STRING SYMB);
BEGIN
RPTR(SYMBOL)TEMP;INTEGER OBTYPE;
! if there is a symbol with the same pname allows recovering;
TEMP←CHECKTOT(SYMB,OBTYPE);
WHILE TEMP≠NULL_RECORD
DO BEGIN
PRINT(SYMB,$SEMSG[9]);
SYMB←RECOVER(SYMB);
TEMP←CHECKTOT(SYMB,OBTYPE);
END;
RETURN(SYMB);
END;
! checks if symb is present in $YMTAB and returns its pointer and its
type (using the reference variable obtype), otherwise allows recovering.
Is used when the symbol required has to be present in $YMTAB (ex.
in EDIT or RENAME instruction);
RPTR(SYMBOL) PROCEDURE OLDSYM(REFERENCE STRING SYMB;REFERENCE INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECKTOT(SYMB,OBTYPE);
! if symbol is not in $YMTAB, recovering is allowed;
WHILE EL=NULL_RECORD
DO BEGIN
PRINT ($SEMSG[6]);
SYMB←RECOVER(SYMB);
EL←CHECKTOT(SYMB,OBTYPE);
END;
RETURN(EL);
END;
! symbol with symbol record sym uses symbol record uses, and this updates it;
INTERNAL PROCEDURE ADDSYMUSED(RPTR(SYMBOL)SYM,USES);
BEGIN
INTEGER NARGS,I,J;
RPTR(SYMBOL) ST;
NARGS←SYMBOL:NUSEDBY[USES];
IF NARGS>0 THEN
FOR I←1 STEP 1 UNTIL NARGS DO IF EXPR:PTR[SYMBOL:USEDBY[USES][I]]=SYM THEN DONE;
IF NARGS=0 OR I>NARGS THEN
BEGIN
RPTR(EXPR)ARRAY SSS[1:NARGS+1];
FOR J←1 STEP 1 UNTIL NARGS DO
SSS[J]←SYMBOL:USEDBY[USES][J];
SSS[NARGS+1]←MK_EXPR(SYM,0,NULL_RECORD);
MEMORY[LOCATION(SYMBOL:USEDBY[USES])]↔MEMORY[LOCATION(SSS)];
SYMBOL:NUSEDBY[USES]←NARGS+1;
END;
END;
! removes SYM from the USEDBY field of USES;
PROCEDURE DELSYMUSED(RPTR(SYMBOL)SYM,USES);
BEGIN
INTEGER NARGS,I,J;
RPTR(SYMBOL) ST;
NARGS←SYMBOL:NUSEDBY[USES];
IF NARGS=0 THEN ERROR("ERROR IN DELSYMUSED");
FOR I←1 STEP 1 UNTIL NARGS DO IF EXPR:PTR[SYMBOL:USEDBY[USES][I]]=SYM THEN DONE;
IF I≤NARGS THEN
IF NARGS>1 THEN
BEGIN
RPTR(EXPR)ARRAY SSS[1:NARGS-1];
FOR J←1 STEP 1 UNTIL I-1 DO
SSS[J]←SYMBOL:USEDBY[USES][J];
IF I≠NARGS-1 THEN
FOR J←I STEP 1 UNTIL NARGS-1
DO SSS[J]←SYMBOL:USEDBY[USES][J+1];
MEMORY[LOCATION(SYMBOL:USEDBY[USES])]↔MEMORY[LOCATION(SSS)];
SYMBOL:NUSEDBY[USES]←NARGS-1;
END
ELSE SYMBOL:NUSEDBY[USES]←0;
END;
PROCEDURE DELSYMREF(RPTR(SYMBOL)SYM);
BEGIN
INTEGER NARGS,I;
IF NARGS←SYMBOL:NUSES[SYM] THEN
FOR I←1 STEP 1 UNTIL NARGS
DO DELSYMUSED(SYM,EXPR:PTR[SYMBOL:USES[SYM][I]]);
SYMBOL:NUSES[SYM]←0;
END;
PROCEDURE DELSYM(RPTR(SYMBOL)EL;INTEGER OBTYPE);
BEGIN
INTEGER ADDRIN,ADDRFN,I;
ADDRIN←#LTYPE*(OBTYPE-#MIN); ! initial addr. in $YMTAB for class;
ADDRFN← $ENTRY[OBTYPE]-1; ! final addr. in $YMTAB for class;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
IF $YMTAB[I]=EL
THEN BEGIN
IF SYMBOL:NUSEDBY[EL]>0 THEN
BEGIN INTEGER J;
STRING S;
S←NULL;
FOR J←1 STEP 1 UNTIL SYMBOL:NUSEDBY[EL]
DO S←S&" "&SYMBOL:PNAME[EXPR:PTR[SYMBOL:USEDBY[EL][J]]];
PRINT(SYMBOL:PNAME[EL]&" IS USED IN FUNCTIONS ",S," WHICH MAY BE AFFECTED");
END;
DELSYMREF(EL);
$YMTAB[I]←$YMTAB[ADDRFN];
$ENTRY[OBTYPE]←ADDRFN; ! move last element into hole;
SYMBOL:VALID[EL]←FALSE;
DONE;
END;
END;
! symbol table: mk_fn, mk_rec ;
INTERNAL RPTR(FUNCTION) PROCEDURE MK_FN(INTEGER ARGS);
BEGIN
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,FUNCTION) ARRAY P[0:ARGS];
STRING ARRAY S[0:ARGS]; INTEGER ARRAY I[0:ARGS];
RPTR(FUNCTION)F; F←NEW_RECORD(FUNCTION);
FUNCTION:NARGS[F]←ARGS;
MEMORY[LOCATION(FUNCTION:ARGNAME[F])]←MEMORY[LOCATION(S)];
MEMORY[LOCATION(FUNCTION:PTR[F])]←MEMORY[LOCATION(P)];
MEMORY[LOCATION(FUNCTION:ARGTYPE[F])]←MEMORY[LOCATION(I)];
MEMORY[LOCATION(I)]←
MEMORY[LOCATION(P)]←MEMORY[LOCATION(S)]←0;
RETURN(F);
END;
INTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PROCEDURE MK_REC(INTEGER TYPE);
BEGIN
RANY TEMP;
REAL ARRAY A[1:5,1:4];
A[1,1]←A[2,2]←A[3,3]←A[4,4]←1.0;
A[5,4]←0;
CASE TYPE OF
begin "case"
[#SC] TEMP←NEW_RECORD(SCALAR);
[#VT] TEMP←NEW_RECORD(VECTOR);
[#RT] BEGIN
TEMP←NEW_RECORD(ROT);
MEMORY[LOCATION(ROT:XF[TEMP])]←MEMORY[LOCATION(A)];
END;
[#TR] BEGIN
TEMP←NEW_RECORD(TRANS);
MEMORY[LOCATION(TRANS:XF[TEMP])]←MEMORY[LOCATION(A)];
END;
[#FR] BEGIN
TEMP←NEW_RECORD(FRAME);
MEMORY[LOCATION(FRAME:XF[TEMP])]←MEMORY[LOCATION(A)];
! insert here the affixment to the world;
FRAME:HOWLINKED[TEMP]←#INDLK; ! independently;
END;
! [#MC] TEMP←NEW_RECORD(MACRO);
[#FN] TEMP←NEW_RECORD(FUNCTION);
ELSE ERROR("PARSER ERROR, NO SUCH RECORD CLASS IN MK_REC")
end "case";
MEMORY[LOCATION(A)]←0;
RETURN(TEMP);
END;
! symbol table: nwr,new_sc,new_vt,new_rt,new_tr,new_fr,dcdsym;
RPTR(SYMBOL)PROCEDURE NWR(STRING SYMB; INTEGER TYP;REFERENCE STRING __LST);
BEGIN
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
SYMB←NEWSYM(SYMB);
VAL←MK_REC(TYP);
TEMP←ENSYM(SYMB,TYP,VAL);
IF TYP=#FR THEN BEGIN FRAME:PNAME[VAL]←SYMB;
IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
FRAME:PNAME[VAL]←SYMB;
FRAME:HOWLINKED[VAL]←#INDLK;
END;
__LST←NULL;
IFC FALSE ∧ #DISPL THENC UPDATE;ENDC
RETURN(TEMP);
END;
DEFINE NEW_SC(DDDDD) "[][]" = [NWR(DDDDD,#SC,$SCLST)];
DEFINE NEW_VT(DDDDD) "[][]" = [NWR(DDDDD,#VT,$VTLST)];
DEFINE NEW_RT(DDDDD) "[][]" = [NWR(DDDDD,#RT,$RTLST)];
DEFINE NEW_TR(DDDDD) "[][]" = [NWR(DDDDD,#TR,$TRLST)];
DEFINE NEW_FR(DDDDD) "[][]" = [NWR(DDDDD,#FR,$FRLST)];
DEFINE NEW_MC(DDDDD) "[][]" = [NWR(DDDDD,#MC,$MCLST)];
DEFINE NEW_FN(DDDDD) "[][]" = [NWR(DDDDD,#FN,$FNLST)];
! checks if the symbol (scalar,vector or rotation) is in $YMTAB;
INTERNAL RPTR(TREE) PROCEDURE DCDSYM(STRING SYMB);
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;
EL←CHECKTOT(SYMB,OBTYPE);
IF EL≠NULL_RECORD
THEN RETURN(NWTREE(EL,OBTYPE))
ELSE RETURN(NWTREE(NULL_RECORD,0));
END;
! symbol table: control,insertion;
RPTR(SYMBOL)PROCEDURE CNVRTR(RPTR(SYMBOL)EL;STRING SYMB);
BEGIN
RPTR(TRANS) TEMP;
TEMP←SYMBOL:OBJECT[EL];
DELSYM(EL,#TR);
EL←NEW_FR(SYMB);
ARRTRAN(FRAME:XF[SYMBOL:OBJECT[EL]],TRANS:XF[TEMP]);
$FRLST←$TRLST←NULL;
END;
! if the symbol symb is present in $YMTAB in the class OBTYPE returns
the pointer to it, otherwise allows recovering. The symbol is passed
by reference so after recovering the new symbol is sent back;
INTERNAL RANY PROCEDURE BELONGS (REFERENCE STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL) EL;
EL←CHECK(SYMB,OBTYPE); ! checks if symbol is present;
WHILE EL=NULL_RECORD
DO BEGIN
IF OBTYPE=#FR
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL
THEN BEGIN
EL←CNVRTR(EL,SYMB);
RETURN(SYMBOL:OBJECT[EL]);
END;
END;
PRINT($SEMSG[OBTYPE-#MIN]);
SYMB←RECOVER(SYMB); ! recover can interrupt the loop and abort;
EL←CHECK(SYMB,OBTYPE);
END;
RETURN(SYMBOL:OBJECT[EL]); ! returns the pointer to the symbol;
END;
! checks if the symbol (scalar,vector or rotation) is in $YMTAB.
If not inserts it, and returns its pointer;
RPTR(SYMBOL) PROCEDURE INSERT(STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECK(SYMB,OBTYPE);
IF EL=NULL_RECORD
THEN CASE OBTYPE OF
BEGIN "CASE"
[#SC] EL←NEW_SC(SYMB);
[#VT] EL←NEW_VT(SYMB);
[#RT] EL←NEW_RT(SYMB);
[#TR] EL←NEW_TR(SYMB);
[#FN] EL←NEW_FN(SYMB)
END "CASE";
RETURN(EL);
END;
! returns the pointer to the frame. If the frame is not present inserts it,
otherwise checks its affixment type and asks for a confirmation if
the affixment type is not independent. In that case recovering is allowed;
INTERNAL RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
BEGIN "A"
RPTR(SYMBOL) EL;
RPTR(FRAME) FRA; STRING TEMP;INTEGER LINK;
WHILE TRUE
DO BEGIN "LOOP"
EL←CHECK(SYMB,#FR); ! if while copying;
IF $HELP=14
THEN WHILE EL≠NULL_RECORD
DO BEGIN
! while copying a new frame is required.
Recovering is allowed if the frame is existent;
PRINT($SEMSG[9]);
SYMB←RECOVER(SYMB);
EL←CHECK(SYMB,#FR);
END;
IF EL=NULL_RECORD
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL THEN EL←CNVRTR(EL,SYMB)
ELSE EL←NEW_FR(SYMB); ! defines a new frame;
RETURN(SYMBOL:OBJECT[EL]);
END
ELSE BEGIN "C"
FRA←SYMBOL:OBJECT[EL];
LINK←FRAME:HOWLINKED[FRA];
! changing values of the frame is allowed if link is #INDLK;
IF LINK=#INDLK
THEN BEGIN
$FRLST←NULL;
RETURN(FRA);
END
ELSE BEGIN
! otherwise a confirmation is required;
PRINT(SYMB,
" affixed frame. Changing values can modify the frame tree.",CRLF,
"You can change the name ");
TEMP←RECOVER(SYMB);
! if the name of the frame is the same,
changing values is allowed;
IF EQU(TEMP ,SYMB)
THEN BEGIN
$FRLST←NULL;
RETURN(FRA);
END
ELSE SYMB←TEMP;
END;
END "C";
END "LOOP";
END "A";
! this procedure is used to initialize the values of the predefined
frames. W,PH,TH are Euler angles, X,Y,Z are the coordinates;
INTERNAL RPTR(TRANS) PROCEDURE DOTREXP(REAL W,PH,TH,X,Y,Z);
BEGIN
RPTR(TRANS) XFE;
XFE←MK_REC(#TR);
SETROT(TRANS:XF[XFE],W,PH,TH);
TRANS:XF[XFE][1,4]←X;
TRANS:XF[XFE][2,4]←Y;
TRANS:XF[XFE][3,4]←Z;
RETURN(XFE);
END;
! symbol table: killtree,killvar,reset;
! removes from $YMTAB all nodes in the subtrees rooted at el;
RECURSIVE PROCEDURE KILLTREE (RPTR(SYMBOL) EL);
BEGIN
RPTR(FRAME)TEMP;
TEMP←SYMBOL:OBJECT[EL];
DELSYM(EL,#FR); ! removes el from $YMTAB;
TEMP←FRAME:SON[TEMP];
WHILE TEMP≠NULL_RECORD DO
BEGIN
EL←CHECK(FRAME:PNAME[TEMP],#FR);
KILLTREE(EL);
TEMP←FRAME:EBRO[TEMP];
END;
END;
! removes the symbol from $YMTAB;
PROCEDURE KILLVAR(REFERENCE STRING VAR;BOOLEAN QUIET(FALSE));
BEGIN
RPTR (SYMBOL) EL;RPTR(FRAME)D;INTEGER OBTYPE;
IF ¬QUIET THEN
EL←OLDSYM(VAR,OBTYPE)
ELSE EL←CHECKTOT(VAR,OBTYPE);
IF EL≠NULL_RECORD THEN
IF EL=WORLD OR EL=BARM OR EL=YARM OR EL=BPARK OR EL=YPARK
OR EL=NILVECT OR EL=XHAT OR EL=YHAT OR EL=ZHAT
OR EL=NILROTN OR EL=NILTRANS OR EL=HANDB OR EL=HANDY
THEN PRINT("I cannot delete ",VAR,CRLF)
ELSE BEGIN "DEL"
IF EQU(VAR,"FIDUCIAL") THEN F_FID←NULL_RECORD
ELSE IF EQU(VAR,"POINTER") THEN F_POINTER←F_ARM←NULL_RECORD
ELSE IF EQU(VAR,"BGRASP") THEN F_BGRASP←NULL_RECORD;
IF OBTYPE≠#FR
THEN BEGIN
DELSYM(EL,OBTYPE);
$DISPLAYLIST[OBTYPE]←NULL;
END
ELSE BEGIN
RPTR(FRAME) TEMP;
TEMP←SYMBOL:OBJECT[EL];
UNLINK(TEMP); ! unfixes the frame;
KILLTREE(EL); ! deletes subtrees rooted in var;
$frlst←null;
END;
END "DEL";
END;
FORWARD PROCEDURE UFX_NODE(RPTR(FRAME)N,D);
FORWARD PROCEDURE READARM(RPTR(FRAME) POS);
! the procedure deletes all the variables defined by the user. It's
called by DELETE with no arguments. If other predefined variables
are inserted the values in the array SAVE have to be accordingly
modified;
PRESET_WITH 7,4,1,1,5,0,0;
INTEGER ARRAY SAVE[#MIN:#MAX];
PROCEDURE RESET;
BEGIN
INTEGER IND,I,TEMP;
! INTEGER ARRAY SAVE[#MIN:#MAX];RPTR(FRAME)WHAT;
! SAVE[#SC]←7; ! 7 scalars predefined in the system;
! SAVE[#VT]←4; ! 4 vectors;
! SAVE[#RT]←1; ! 1 rotation;
! SAVE[#TR]←1; ! 1 trans;
! SAVE[#FR]←5; ! 5 frames;
FOR IND←#MIN STEP 1 UNTIL #MAX DO
BEGIN
! deletes the records defined for each type saving the predefined ones;
TEMP←$ENTRY[IND]-1;
FOR I←#LTYPE*(IND-#MIN)+SAVE[IND] STEP 1 UNTIL TEMP DO
BEGIN SYMBOL:VALID[$YMTAB[I]]←FALSE;$YMTAB[I]←NULL_RECORD; END;
$ENTRY[IND]←#LTYPE*(IND-#MIN)+SAVE[IND]; ! remembers the new $ENTRY to $YMTAB;
END;
! updates the frame tree structure;
$ALLOW←$ALLOW+1;
! kills the sons of WORLD,unless the predefined ones;
WHAT←FRAME:SON[F_WRLD];
WHILE WHAT AND WHAT≠F_BARM AND WHAT≠F_YARM AND WHAT≠F_BPARK AND WHAT≠F_YPARK
DO BEGIN
UNLINK(WHAT);
WHAT←FRAME:SON[F_WRLD];
END;
! kills the sons of BARM and YARM;
FRAME:SON[F_BARM]←FRAME:SON[F_YARM]←NULL_RECORD;
F_FID←F_POINTER←F_BGRASP←NULL_RECORD;
! clears BARM to define again BGRASP and POINTER, then read_barm;
ARRTRAN(FRAME:XF[F_BARM],TRANS:XF[T_NILTRANS]);
! defines again BGRASP;
FRAME:PNAME[SYMBOL:OBJECT[BGRASP←ENSYM("BGRASP",#FR,F_BGRASP←MK_REC(#FR))]]
←"BGRASP";
ARRTRAN(FRAME:XF[F_BGRASP],TRANS:XF[DOTREXP(-180,180,0,0,0,0)]);
AFX_NODE(F_BGRASP,F_BARM,#RGDLK);
! defines again POINTER;
FRAME:PNAME[SYMBOL:OBJECT[POINTER←ENSYM("POINTER",#FR,F_POINTER←MK_REC(#FR))]]
←"POINTER";
ARRTRAN(FRAME:XF[F_POINTER],
TRANS:XF[DOTREXP(-.417,13.2,-5.173,.0121,.119,3.75)]);
AFX_NODE(F_POINTER,F_BARM,#RGDLK);
F_ARM←F_BARM;
! updates the arm position;
READARM(F_BARM);
$ALLOW←$ALLOW-1;
FOR I←#MIN STEP 1 UNTIL #MAX DO $DISPLAYLIST[I]←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! assignment instruction;
! assigns to first the value of ob2. If first has not been declared
the procedure determines the type of first, according to the value
of obtype;
BOOLEAN PROCEDURE PRDECL(RPTR(SYMBOL) OB1);
RETURN( OB1=INCHES OR OB1=DEG OR OB1=HANDB OR OB1=HANDY OR OB1=INCH OR
OB1=DEGRES OR OB1=DEG
OR OB1=XHAT OR OB1=YHAT OR OB1=ZHAT OR OB1=NILVECT
OR OB1=NILROTN
OR OB1=NILTRANS
OR OB1=YPARK OR OB1=BPARK OR OB1=WORLD);
PROCEDURE ASGEXP(STRING FIRST; RANY OB2;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL) OB1;
$ALLOW←$ALLOW+1; ! to avoid updating display;
IF OBTYPE=#FR
THEN BEGIN
REAL ARRAY FXF[1:5,1:4];RPTR(FRAME) FR1;
FR1←FR_INSERT(FIRST);
ABSXF(OB2,FXF);
SETABS(FR1,FXF);
END
ELSE BEGIN
OB1←INSERT(FIRST,OBTYPE); ! inserts in $YMTAB,if not inserted;
IF PRDECL(OB1) THEN ABORT1(FIRST,$SEMSG[14]);
SYMBOL:OBJECT[OB1]←OB2; ! check to insure that dont change xhat,etc;
END;
$DISPLAYLIST[OBTYPE]←NULL;
$ALLOW←$ALLOW-1; ! for display;
IFC #DISPL THENC UPDATE;ENDC
END;
! tree operations: affixcode,unfixcode (afx_node);
! affixes the frame pointed by n to the frame pointed by d, as indicated
by how;
INTERNAL
PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
BEGIN
OWN REAL ARRAY XFTMP1,XFTMP2[1:5,1:4];
IF HOW=#INDLK
THEN ABSXF(N,FRAME:XF[N])
ELSE BEGIN ! xf[n]←inv(absxf[d])*absxf[n];
ABSXF(D,XFTMP2);
XFINV(XFTMP2,XFTMP1);
ABSXF(N,XFTMP2);
XFXF(XFTMP1,XFTMP2,FRAME:XF[N]);
END;
LINKFR(N,D); ! sets links in frame tree;
FRAME:HOWLINKED[N]←HOW;
END;
PROCEDURE UFX_NODE(RPTR(FRAME)EL1,EL2);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];
ABSXF(EL1,FXF); ! fxf=absolute value of frame1;
ARRTRAN(FRAME:XF[EL1],FXF); ! assigns absolute value to frame;
UNLINK(EL1); ! breaks links in tree;
FRAME:HOWLINKED[EL1]←#INDLK;
LINKFR(EL1,F_WRLD); ! sets new links;
END;
! affixes frame1 to frame2, as indicated by afftype;
PROCEDURE AFFIXCODE(STRING FRAME1,FRAME2; INTEGER AFFTYPE);
BEGIN
RPTR(FRAME) N,D;
D←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
N←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
AFX_NODE(N,D,AFFTYPE); ! affixes n to d;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! unfixes frame1 and affixes it independently to world;
PROCEDURE UNFIXCODE(STRING FRAME1,FRAME2);
BEGIN
RPTR(FRAME)EL1,EL2;
EL1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
EL2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
IF EL2≠F_WRLD
THEN
WHILE FRAME:DAD[EL1]≠EL2
DO BEGIN
PRINT(FRAME2," is not the dad of ",FRAME1," Try again ");
FRAME2←RECOVER(FRAME2);
EL2←BELONGS(FRAME2,#FR);
END;
UFX_NODE(EL1,EL2);
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! tree operations: copycode,copy,copy_tree;
! copies the subtree rooted at startfr and affixes it to finalfr.
Prefix is used to build the names of the new frames;
PROCEDURE PCOPY(RPTR(FRAME) STARTFR,FINALFR; STRING PREFIX);
BEGIN
OWN REAL ARRAY FXF[1:5,1:4];INTEGER LINK;RPTR(FRAME)ROOT;
RPTR(FRAME) RECURSIVE PROCEDURE COPY_TREE(RPTR(FRAME) ND);
BEGIN
! copies the structure rooted at ND. Leaves copy (NND)
affixed to DAD[ND];
RPTR(FRAME) NND,KIDS;
STRING OLDNAME,LEAVE,NEWNAME;
OLDNAME←FRAME:PNAME[ND];
! constructs the new name of the frame: if the name of the copied
frame contains an underscore, the part before it is substituted
by prefix, otherwise prefix is prefixed;
LEAVE←SCAN(OLDNAME,$DSHTAB,$BRCHR);
IF $BRCHR≠0
THEN NEWNAME←PREFIX&OLDNAME
ELSE NEWNAME←PREFIX&LEAVE;
NND←FR_INSERT(NEWNAME); ! inserts a new frame;
ARRTRAN(FRAME:XF[NND],FRAME:XF[ND]);
FRAME:HOWLINKED[NND]←FRAME:HOWLINKED[ND];
KIDS←FRAME:SON[ND];
WHILE KIDS≠NULL_RECORD DO
BEGIN
LINKFR(COPY_TREE(KIDS),NND);
KIDS←FRAME:EBRO[KIDS];
END;
RETURN(NND);
END;
ROOT←COPY_TREE(STARTFR); ! copies the subtree;
LINKFR(ROOT,FINALFR); ! sets new links;
IFC #DISPL THENC UPDATE;ENDC
END;
! merges the subtrees under startfr as sons of finalfr. Prefix is
used to build the names of new frames;
PROCEDURE PMERGE(RPTR(FRAME) STARTFR,FINALFR;STRING PREFIX);
BEGIN
RPTR(FRAME)TEMP,BROTHER;
TEMP←FRAME:SON[STARTFR];
DO BEGIN
BROTHER←FRAME:EBRO[TEMP];
PCOPY(TEMP,FINALFR,PREFIX); ! copies one subtree;
TEMP←BROTHER;
END
UNTIL TEMP=NULL_RECORD;
END;
! executes copy or merge operation on frame1 and frame2. Name indicates
the required operation(copy/merge);
PROCEDURE COPYCODE(STRING NAME,FRAME1,FRAME2);
BEGIN
RPTR(FRAME) FR1,FR2;STRING PREFIX,ANSWER;
$ALLOW←$ALLOW+1;
FR1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
FR2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
! chooses the prefix for the new names: if the name of frame2 contains an
underscore takes the part before it, otherwise takes the first three
characters (long names) or all the name and asks for a confirmation;
ANSWER←FRAME:PNAME[FR2];
PREFIX←SCAN(ANSWER,$DSHTAB,$BRCHR);
IF $BRCHR=0 AND
LENGTH(PREFIX)>5 THEN
PREFIX←FRAME:PNAME[FR2] [1 FOR 3];
PRINT("it's OK to prefix to the new names ");
PREFIX←RECOVER(PREFIX)&"_";
IF NAME="COPY"
THEN PCOPY(FR1,FR2,PREFIX)
ELSE PMERGE(FR1,FR2,PREFIX);
$ALLOW←$ALLOW-1;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! arm interactions: read_pos,readarm,frasg;
! assigns the value of pos(pointer or arm) to the frame fra. If direct
is indicated uses it to set the rotation part;
IFC #MOVE THENC
REQUIRE "ARMINT.SAI" SOURCE_FILE;
ELSEC
PROCEDURE READ_BLUE; ;
ENDC
! reads the position of yellow arm (TEMPORARY);
PROCEDURE READ_YELLOW(REAL ARRAY AXF);
BEGIN
INTEGER I;STRING AA; REAL ARRAY COMP[1:6];
PRINT(" Assign 6 values (angles and positions)",CRLF);
FOR I← 1 STEP 1 UNTIL 6 DO
BEGIN
AA←INCHWL;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,AA,CRLF);ENDC
COMP[I]←REALSCAN(AA,$BRCHR);
END;
SETROT(AXF,COMP[1],COMP[2],COMP[3]);
AXF[1,4]←COMP[4];
AXF[2,4]←COMP[5];
AXF[3,4]←COMP[6];
END;
! This procedure finds out where the arm actually is and then
stores this frame as the absolute frame of the arm in the
subpart hierarchy.;
PROCEDURE READARM(RPTR(FRAME) POS);
BEGIN
OWN REAL ARRAY AXF[1:5,1:4];
$FRLST←NULL; ! frame tree modification;
IF POS = F_BARM
THEN READ_BLUE
ELSE IF POS=F_YARM
THEN BEGIN
PRINT ("simulation of reading on ",frame:pname[pos]);
READ_YELLOW(AXF);
SETABS(POS,AXF);
END;
END;
! returns the pointer to the input device pos (arm or pointer);
RPTR (FRAME) PROCEDURE INPT_DEV(REFERENCE STRING POS);
BEGIN
RPTR(FRAME) FROM;
IF EQU(POS,"BARM")
THEN RETURN(F_BARM)
ELSE IF EQU(POS,"YARM")
THEN RETURN(F_YARM)
ELSE BEGIN
FROM←BELONGS(POS,#FR);
WHILE FROM≠F_BARM AND FROM≠F_YARM AND FROM≠F_POINTER
DO BEGIN
PRINT ($SEMSG[12]);
POS←RECOVER(POS);
FROM←BELONGS (POS,#FR);
END;
RETURN(FROM);
END;
END;
! reads the position of the arm from, or of the arm with pointer;
PROCEDURE READ_DEV(RPTR(FRAME) FROM);
IF FROM=F_POINTER THEN READARM(F_ARM) ELSE READARM(FROM);
! reads the position of the device pos (arm or pointer);
PROCEDURE INPT(REFERENCE STRING POS);
BEGIN
RPTR(FRAME)FROM;
FROM←INPT_DEV(POS);
READ_DEV(FROM);
END;
! arm interactions: arm_check,goarm,movefrfr;
IFC #MOVE THENC
! returns the pointer to the arm affixed to obj;
RPTR(FRAME) PROCEDURE ARM_CHECK(RPTR(FRAME) OBJ);
BEGIN
RPTR(FRAME) TEMP;
IF OBJ=F_POINTER THEN RETURN(F_ARM);
TEMP←OBJ;
WHILE TEMP≠F_WRLD DO
IF TEMP=F_BARM OR TEMP=F_YARM THEN RETURN(TEMP)
ELSE TEMP←FRAME:DAD[TEMP];
ABORT1(FRAME:PNAME[OBJ],$SEMSG[8]);
END;
! This procedure moves the arm MVARM to BXF;
PROCEDURE GOARM(RPTR(FRAME)ARRAY MVFRS; INTEGER NFRAMES(1));
BEGIN
IF MVFRS[0]=F_BARM
THEN MMOVE(MVFRS,NFRAMES)
ELSE PRINT("simulation of yarm movement ",CRLF);
SETABS(MVFRS[0],FRAME:XF[MVFRS[NFRAMES]]); ! sets value of arm;
END;
! Suppose the absolute frame of the arm is AXF
the absolute frame of "motion" is MXF
and we want the new motion frame to be DEST.
We therefore have to compute the new arm frame BXF.
This means MXF = AXF * X where X is the displacement trans between the
arm and the motion frames. So X = inverse(AXF) * MXF. Then DEST = BXF * X
So, BXF = DEST * inverse(X) = DEST * inverse(MXF) * AXF.;
RPTR(FRAME)PROCEDURE MOVEFRFR(RPTR(FRAME) MVARM,OBJ,DEST); ! used to be trans procedure;
BEGIN
OWN REAL ARRAY MXF[1:5,1:4],
AXF[1:5,1:4],
TMP[1:5,1:4];
RPTR(FRAME) BXF;
BXF←MK_REC(#FR);
if mvarm=obj
then arrtran(FRAME:xf[bxf],FRAME:xf[dest])
else begin
ABSXF(MVARM,AXF); ! AXF is arm frame;
ABSXF(OBJ,MXF); ! MXF is motion frame;
INVXFX(MXF,AXF,TMP); ! TMP = inv(MXF) * AXF;
ABSXF(DEST,AXF);
XFXF(AXF,TMP,FRAME:XF[BXF]); ! BXF = DEST*inv(MXF)*AXF;
end;
RETURN(BXF);
END;
ENDC
! arm interactions: mvfrcode,mvfrexp;
! moves fr1 to fr2 + expl.vect WRT rel (fr2 can be ⊗);
IFC #MOVE THENC
PROCEDURE MVFREXP (RPTR(FRAME)FR1,FR2);
BEGIN
RPTR(FRAME)TEMP;RPTR(FRAME)MVARM;
$ALLOW←$ALLOW+1;
IF FR1=F_BARM AND FR2=F_BPARK
THEN BEGIN RPTR(FRAME)ARRAY FFR[0:1];
FFR[0]←F_BARM; FFR[1]←F_BPARK;
GOARM(FFR);
END
ELSE BEGIN "MOVE"
RPTR(FRAME) ARRAY FFR[0:1];
! checks frame1 is movable and finds the arm which is affixed to;
MVARM←ARM_CHECK(FR1);
IF MVARM=F_BARM THEN READARM(MVARM); ! reads exact postion of arm;
TEMP←MOVEFRFR(MVARM,FR1,FR2);
! moves the arm ;
FFR[0]←MVARM;FFR[1]←TEMP;
GOARM(FFR);
END "MOVE";
$ALLOW←$ALLOW-1;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END ;
PROCEDURE MVFRSEXP(RPTR(FRAME)ARRAY FDESTS; INTEGER NFDEST(1));
IF NFDEST=1 THEN MVFREXP(FDESTS[0],FDESTS[1])
ELSE BEGIN
RPTR(FRAME) ARRAY FFR[0:NFDEST];
RPTR(FRAME)MVARM,TEMP;
INTEGER J;
IF (MVARM←ARM_CHECK(FDESTS[0]))=F_BARM
THEN READARM(MVARM);
FFR[0]←MVARM;
TEMP←FDESTS[0];
FOR J←1 STEP 1 UNTIL NFDEST DO
FFR[J]←MOVEFRFR(MVARM,TEMP,FDESTS[J]);
GOARM(FFR,NFDEST);
END;
ENDC
! arm interactions: centercode,closecode,opencode,fconstructproc;
IFC #MOVE THENC
! executes center instruction;
PROCEDURE CENTERCODE(STRING POS);
BEGIN
IF POS="BARM"
THEN BEGIN
CENTER(BLUE);
READARM(F_BARM);
$FRLST←NULL;
$SCLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE PRINT(#NOTYET);
END;
! executes close or open instruction. How determines if the movement is
absolute (to) or differential (by), op indicates the operation(open/close);
PROCEDURE OPCLCODE(STRING OP,HAND,HOW;REAL SCAL);
BEGIN
IF HAND="BHAND"
THEN BEGIN
IF HOW="TO"
THEN DRIVE(BLUE,7,ABS_MOTION,SCAL)
ELSE IF OP="CLOSE"
THEN DRIVE(BLUE,7,REL_MOTION,-SCAL)
ELSE DRIVE(BLUE,7,REL_MOTION,SCAL);
READARM(F_BARM);
$SCLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE PRINT(#NOTYET);
END;
! drives the indicated joint of the arm (what): movement is absolute
if how=to, differential if how=by;
PROCEDURE DRIVECODE(STRING WHAT,HOW;INTEGER JOINT;REAL SCAL);
BEGIN
IF EQU(WHAT,"BJT")
THEN BEGIN
IF EQU(HOW,"BY")
THEN DRIVE(BLUE,JOINT,REL_MOTION,SCAL)
ELSE DRIVE(BLUE,JOINT,ABS_MOTION,SCAL);
READARM(F_BARM);
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE IF EQU(WHAT,"YJT")
THEN PRINT(#NOTYET);
END;
ENDC
! reads an axis name and returns its number:
xhat=0,yhat=1,zhat=2;
INTEGER PROCEDURE INPT_AXIS(REFERENCE STRING AXIS);
BEGIN
LABEL LL;
LL: AXIS←RECOVER(AXIS);
IF EQU(AXIS,"XHAT") THEN RETURN(0)
ELSE IF EQU(AXIS,"YHAT") THEN RETURN(1)
ELSE IF EQU(AXIS,"ZHAT") THEN RETURN(2)
ELSE BEGIN
PRINT($SYNMSG[17],$SYNMSG[25],CRLF,"Try again ");
GOTO LL;
END;
END;
RPTR(TRANS) ARRAY T_CSTR[1:3];
! used by CONSTRUCT instruction;
! performs a construct instruction, without arguments;
PROCEDURE FCONSTRUCTPROC;
BEGIN
RPTR(FRAME) ELF;RPTR(TRANS)XFE;INTEGER I;
RPTR(FRAME) FROM;STRING POS,ANSWER,FIRST;
RPTR(VECTOR) V1,V2,V3;
PRELOAD_WITH
"move arm to the origin of the frame"&CRLF,
"move arm to the axis ",
"move arm to the plane ";
OWN STRING ARRAY INFORM[1:3];
STRING AXIS;INTEGER F_AXIS,S_AXIS;
$ALLOW←$ALLOW+1;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN ERROR("Need undeclared token for FCONSTRUCT")
ELSE FIRST←TOKEN;
AXIS←NULL;
IF F_POINTER=NULL_RECORD
THEN PRINT("pointer is not defined cannot be used",CRLF)
ELSE POS←"POINTER";
PRINT("three positions are required",CRLF);
FOR I←1 STEP 1 UNTIL 3 DO
BEGIN
! determination of the input device required;
PRINT("position ",I," read on ");
POS←RECOVER(POS);
FROM←INPT_DEV(POS); ! checks the input device;
! determination of the positions for reading;
PRINT(INFORM[I]);
IF I=2
THEN F_AXIS←INPT_AXIS(AXIS)
ELSE IF I=3
THEN BEGIN
PRINT(AXIS," - ");
AXIS←NULL;
S_AXIS←INPT_AXIS(AXIS);
IF S_AXIS=F_AXIS THEN ABORT1($SEMSG[13]);
END;
! reading of the arm position;
PRINT("type <cr> when the arm is at the desired position");
ANSWER←INCHRW;
IF ANSWER=CR
THEN ANSWER←INCHRW
ELSE ABORT1($SEMSG[13]);
READ_DEV(FROM); ! raads the appropriate arm pos.;
T_CSTR[I]←ABSLOC(FROM);
END;
! extraction of translation part;
V1←TPOS(T_CSTR[1]);
V2←TPOS(T_CSTR[2]);
V3←TPOS(T_CSTR[3]);
XFE←VVVTR(V1,V2,V3,F_AXIS,S_AXIS);
ELF←FR_INSERT(FIRST); ! inserts the new frame;
ABSSET(ELF,XFE); ! sets the new value;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END;
! system facilities: editcode,renmcode;
PROCEDURE UNRAVEL_SYMBOLS_USED(RPTR(expr)SYMBOLSUSED;RPTR(SYMBOL)EL);
BEGIN RPTR(SYMBOL)EL2;
RPTR(expr)SY,SY2; INTEGER NARGS; NARGS←0;
SY←SYMBOLSUSED;
WHILE SY≠NULL_RECORD DO BEGIN NARGS←NARGS+1; SY←EXPR:NEXT[SY]; END;
IF NARGS>0 THEN
BEGIN RPTR(EXPR)ARRAY SS[1:NARGS]; INTEGER I;
SY←SYMBOLSUSED;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
INTEGER J,JJ;
SS[I]←SY;
EL2←EXPR:PTR[SY];
ADDSYMUSED(EL,EL2);
SY←EXPR:NEXT[SY2←SY];
EXPR:NEXT[SY2]←NULL_RECORD;
END;
MEMORY[LOCATION(SYMBOL:USES[EL])]←MEMORY[LOCATION(SS)];
MEMORY[LOCATION(ss)]←0;
SYMBOL:NUSES[EL]←NARGS;
END;
END;
! edits values of the variable var;
PROCEDURE EDITCODE (STRING VAR);
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING FBODY;
RPTR(SCALAR,VECTOR,TRANS,FRAME,ROT,MACRO,FUNCTION) TEMP;
RPTR(TREE) TEMP1;
RPTR(PLIST) PPML;
STRING SSSS;
NOEXPAND ← TRUE;
EL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
TEMP←SYMBOL:OBJECT[EL];
IF OBTYPE = #MC
THEN BEGIN
SSSS ← EWDYSCODE(EL);
DELSYM(EL,#MC);
EWDSPL(SSSS,ED_M);
END
ELSE BEGIN
SETFORMAT(0,7);
IF PRDECL(EL) OR EL=HANDB OR EL=HANDY
OR EL=BARM OR EL=YARM
OR EL=BGRASP
THEN ABORT1(VAR,$SEMSG[14]);
IF OBTYPE=#FR AND FRAME:HOWLINKED[TEMP]≠#INDLK
THEN PRINT("values of ",VAR," are relative to ",
FRAME:PNAME[FRAME:DAD[TEMP]],CRLF)
ELSE IF OBTYPE=#FN THEN VAR←FUNCTION:HEAD[TEMP];
PRINT("value of ",VAR," = ");
CASE OBTYPE OF
BEGIN "CASE"
[#SC] LODED( CVGX(SCALAR:VALUE[TEMP])&CR);
[#VT] LODED(STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8)&CR);
[#RT] LODED(STR_RT(ROT:XF[TEMP])&CR);
[#FR] LODED("FRAME "&STR_TR(FRAME:XF[TEMP],1,8)&CR);
[#TR] LODED(STR_TR(TRANS:XF[TEMP],1,8)&CR);
[#FN] LODED(FUNCTION:BODY[TEMP]&CR)
END "CASE";
ASKUSER;
IF OBTYPE=#FN THEN α RPTR(EXPR)SYMBOLSUSED;
TEMP1←FNEXPR(TEMP,FBODY,SYMBOLSUSED);
BEGIN RPTR(EXPR) T;
T←NEW_RECORD(EXPR);
EXPR:PTR[T]←TREE:DATA[TEMP1];
EXPR:TYPE[T]←TREE:DTYPE[TEMP1];
FUNCTION:EXPR[TEMP]←T;
END;
DELSYMREF(EL);
UNRAVEL_SYMBOLS_USED(SYMBOLSUSED,EL);
FUNCTION:BODY[TEMP]←FBODY; β
ELSE α TEMP1←GTEXPR;
IF TREE:DTYPE[TEMP1]≠OBTYPE THEN ABORT1("new value incompatible with variable type")
ELSE IF OBTYPE=#FR THEN
ARRTRAN(FRAME:XF[TEMP],FRAME:XF[tree:data[TEMP1]]);
SYMBOL:OBJECT[EL]←TREE:DATA[TEMP1]; β;
$DISPLAYLIST[OBTYPE]←NULL;
SETFORMAT(0,3);
END;
NOEXPAND ← FALSE;
IFC #DISPL THENC UPDATE;ENDC
END;
! allows renaming a variable;
PROCEDURE RENMCODE(STRING VAR);
BEGIN
RPTR(SYMBOL)OLDEL;INTEGER OBTYPE;STRING NEW;
STRING SFSF;
NOEXPAND ← TRUE;
SFSF ← VAR;
OLDEL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
PRINT("new name = ");
NEW←RECOVER(VAR); ! reads the new name;
IF NEW NEQ SFSF
THEN NEW←NEWSYM(NEW); ! checks new doesn't exist;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,NEW,CRLF);ENDC
SYMBOL:PNAME[OLDEL]←NEW; ! changes the name in record symbol;
IF OBTYPE=#FR
THEN FRAME:PNAME[SYMBOL:OBJECT[OLDEL]]←NEW;
$DISPLAYLIST[OBTYPE]←NULL;
IFC #DISPL THENC UPDATE;ENDC
NOEXPAND ← FALSE;
END;
! parse procedures: affixproc,bailcall,defineproc,promptproc;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
PROCEDURE AFFIXPROC;
BEGIN
STRING FR1,FR2;INTEGER AFFTYPE;
$HELP←16;
FR1←IDF_READ; ! first frame;
TO_READ;
FR2←IDF_READ; ! second frame;
GTOKEN(FALSE);
IF EQU(TOKEN,"AT")
THEN BEGIN "AT"
! DO IN A BETTER WAY;
! CHECK IF THE RETURNED POINTER IS A TRANS;
RPTR(TREE)TEMP;RPTR(FRAME)EL;
$ALLOW←$ALLOW+1;
TEMP←GTEXPR; ! reads TRANS part;
EL←RELFR(BELONGS(FR2,#FR),TREE:DATA[TEMP]);
! assigns to fr1 the value of comp as relative to fr2;
ASGEXP(FR1,EL,#FR);
GTOKEN(FALSE);
$ALLOW←$ALLOW-1;
END "AT";
IF FINAL
THEN AFFIXCODE(FR1,FR2,#RGDLK)
ELSE BEGIN "D"
IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY")
THEN AFFTYPE← #NRGLK
ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY")
THEN AFFTYPE← #RGDLK
ELSE ERROR($SYNMSG[30],NULL);
SEMICOL_READ;
AFFIXCODE(FR1,FR2,AFFTYPE);
END "D";
END ;
IFC #DEBUG THENC
PROCEDURE BAILCALL;
BEGIN
SEMICOL_READ;
$ALLOW←$ALLOW+1; ! no display with bail;
BAIL;
$ALLOW←$ALLOW-1;
END;
ENDC
PROCEDURE PROMPTPROC;
BEGIN
SEMICOL_READ;
OUTSTR(CRLF&"WAITING FOR PROMPT FROM YOU - TYPE CARRIAGE RETURN");
INCHWL;
END;
! ** new code for macro feature;
PROCEDURE ERRD1;
ERROR("error in macro definition: MACRONAME has been used before");
PROCEDURE ERRD2;
ERROR("error in macro definition: = missing");
PROCEDURE ERRD3;
ERROR("error in macro definition: = missing or ) mismatched");
PROCEDURE ERRD4;
ERROR("error in macro definition: ⊂ missing");
PROCEDURE ERRD5;
ERROR("error in macro definition: , missing");
PROCEDURE ERRD6;
ERROR("error in macro definition: only undeclared variables may be used as parameters");
PROCEDURE ERRD8;
ERROR("error in macro definition: , SUPERFLOUS");
PROCEDURE ERRD9;
ERROR("error in macro definition: ) MISMATCHED ");
PROCEDURE DEFINEPROC;
BEGIN
NOEXPAND ← TRUE;
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERRD1
ELSE BEGIN
RPTR(MACRO) MACPRT;
RPTR(SYMBOL) SYMPRT;
STRING TEMPPN;
INTEGER DDLCOUNT;
DDLCOUNT ← 0;
MACPRT ← NEW!RECORD(MACRO);
TEMPPN ← TOKEN;
GTOKEN;
IF EQU(TOKEN,"(")
THEN BEGIN
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERRD6;
WHILE TRUE
DO BEGIN
RPTR(PLIST) TEMP;
MACRO:NPARAM[MACPRT]←MACRO:NPARAM[MACPRT]+1;
TEMP←NEW!RECORD(PLIST);
PLIST:NEXTP[TEMP]←MACRO:PARLST[MACPRT];
PLIST:PARAM[TEMP]←TOKEN;
MACRO:PARLST[MACPRT]←TEMP;
GTOKEN;
IF EQU(TOKEN,")")
THEN DONE;
IF TOKEN NEQ ","
THEN ERRD5
ELSE GTOKEN;
IF EQU(TOKEN,",") OR EQU(TOKEN,")")
THEN ERRD8;
IF EQU(TOKEN,"=") OR EQU(TOKEN,"⊂")
THEN ERRD9;
IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERRD6;
END;
GTOKEN;
IF TOKEN NEQ "="
THEN ERRD2;
END
ELSE IF TOKEN NEQ "="
THEN ERRD2;
GTOKEN;
IF TOKEN NEQ "⊂"
THEN ERRD4;
DDLCOUNT ← 1;
GTOKEN;
IF TOKEN = "⊂"
THEN DDLCOUNT ← DDLCOUNT + 1;
IF TOKEN = "⊃"
THEN DDLCOUNT ← DDLCOUNT - 1;
WHILE DDLCOUNT ≠ 0
DO BEGIN
MACRO:BODY[MACPRT]←MACRO:BODY[MACPRT] & TOKEN & '40;
GTOKEN;
IF TOKEN = "⊂"
THEN DDLCOUNT ← DDLCOUNT + 1;
IF TOKEN = "⊃"
THEN DDLCOUNT ← DDLCOUNT - 1;
END;
SEMICOL_READ;
SYMPRT←ENSYM(TEMPPN, #MC, MACPRT);
! returns pointer to new record SYMBOL in SYMPRT;
! inserts in PNAME of new record SYMBOL the macroname;
! insert in OBJECT of new record SYMBOL the pointer
MACPRT to new record MACRO;
NOEXPAND ← FALSE;
END;
END;
! parse procedures: centerproc,opclproc,constread,copyproc;
! parses the instruction
CENTER <arm>;
IFC #MOVE THENC
PROCEDURE CENTERPROC;
BEGIN "A"
STRING POS;
$HELP←24;
POS←ARM_READ; ! if the arm is not indicated BARM is assumed;
CENTERCODE(POS);
END "A";
ENDC
! parses the part of the instruction "<scalar>;
PROCEDURE OPENING(STRING FIRST,WHAT,HOW);
IFC #MOVE THENC
BEGIN
RPTR(TREE)SCAL;
$HELP←23;
SCAL←GTEXPR;
IF TREE:DTYPE[SCAL]≠#SC THEN ABORT1("scalar expected");
OLDSAV(FIRST,WHAT); ! saves for default instructions;
OPCLCODE(FIRST,WHAT,HOW,SCALAR:VALUE[TREE:DATA[SCAL]]);
END;
ELSEC ;ENDC
! parses the instructions
OPEN <hand> TO|BY <scalar>;
! CLOSE <hand> TO|BY <scalar>;
IFC #MOVE THENC
PROCEDURE OPCLPROC(STRING FIRST);
BEGIN
STRING WHAT,HOW;
$HELP←23;
WHAT←HAND_READ;
HOW←IDF_READ;
IF EQU(HOW,"TO") OR EQU(HOW,"BY")
THEN OPENING(FIRST,WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END;
ENDC
! closes any open file, after a confirmation;
PROCEDURE FCLPROC;
BEGIN
STRING ANSWER;
$HELP←36;
SEMICOL_READ;
PRINT("Any open file will be closed. Are you sure?");
ANSWER←INCHRW;
PRINT(CRLF);
ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN BEGIN
IFC #OUTPT THENC FCLOSE;ENDC
END
ELSE ABORT1($SEMSG[13]);
IFC #OUTPT THENC TTYSAVE; ENDC ! file status modified;
$OULST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
! parses the instructions
CLOSE {<filename>} (default=last used file)
CLOSE <hand> TO|BY <scalar> (BHAND as default);
PROCEDURE CLOSEPROC;
BEGIN
STRING FL,ANSWER;
$HELP←30;
GTOKEN(FALSE);
IF FINAL THEN
IFC #OUTPT THENC AL_CLOSE($ALFL) ELSEC ABORT1(#VERSION) ENDC
ELSE
BEGIN "MORE"
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
OR EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN BEGIN "HAND"
STRING WHAT; INTEGER IND;
WHAT←TOKEN;
GTOKEN(FALSE);
IF FINAL
THEN
IFC #OUTPT THENC
BEGIN "FILECHECK"
IND←ISFILE(WHAT);
IF IND THEN
BEGIN
PRINT("do you want to close the file?");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN AL_CLOSE(WHAT)
ELSE ABORT1($SEMSG[13]);
END
ELSE
IF EQU(WHAT,"BHAND") OR EQU(WHAT,"YHAND") THEN
BEGIN
STRING HOW;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN OPENING("CLOSE",WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE OPENING("CLOSE","BHAND",WHAT);
END "FILECHECK"
ELSEC PRINT(#VERSION) ENDC
ELSE
IF EQU(WHAT,"TO") OR EQU(WHAT,"BY") THEN
BEGIN
STOKEN←TRUE;
OPENING("CLOSE","BHAND",WHAT); ! default=BHAND;
END
ELSE
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY") THEN
OPENING("CLOSE",WHAT,TOKEN)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END "HAND"
ELSE
BEGIN
STOKEN←TRUE;
FL←NAMEFILE;
SEMICOL_READ;
IFC #OUTPT THENC AL_CLOSE(FL);ENDC
END;
END "MORE";
IFC #DISPL THENC UPDATE;ENDC
END;
! parses the instructions
MERGE <frame_id> INTO <frame_id>
COPY <frame_id> INTO <frame_id>
First is MERGE or COPY;
! MERGE <frame_id> is now COPY SUBTREE(<frame_id>) ;
PROCEDURE COPYPROC;
BEGIN
STRING FR1,FR2,FIRST;
$HELP←14;
GTOKEN;
IF EQU(TOKEN,"SUBTREE") THEN
BEGIN
LPAR_READ; FR1←IDF_READ;
RPAR_READ; FIRST←"MERGE";
END
ELSE
BEGIN
STOKEN←TRUE;
FR1←IDF_READ; ! reads first frame;
FIRST←"COPY";
END;
INTO_READ; ! reads INTO;
FR2←IDF_READ; ! reads second frame;
SEMICOL_READ;
COPYCODE(FIRST,FR1,FR2);
END;
! parse procedures: declproc,deleteproc,driveproc,editproc,printproc,exitproc,explass,freeproc;
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...;
PROCEDURE FUNCTPROC(INTEGER OBTYPE(0);STRING OBSTRING(NULL));
BEGIN
STRING SSSS;
PROCEDURE GGTOKEN;
BEGIN GTOKEN; SSSS←SSSS&" "&TOKEN; END;
SSSS←OBSTRING&" "&TOKEN;
$HELP←0;
BEGIN "declar function"
INTEGER NARGS; RPTR(SYMBOL) S;integer tt,FT; STRING FBODY;
RPTR(EXPR) SYMBOLSUSED;
RCLASS TEMP(RPTR(EXPR) PTR; INTEGER TYPE;
STRING NAME;RPTR(TEMP)NEXT);
RPTR (TEMP) T,T1;RPTR(TREE)TRE;RPTR(FUNCTION) F; STRING FNAME;
NARGS←0; GGTOKEN;
IF #TOKEN≠UNDECLARED_TYPE
THEN ERROR($SYNMSG[35],$SYNMSG[25])
ELSE BEGIN "declar function"
FNAME←TOKEN;
GGTOKEN; T←NEW_RECORD(TEMP);
IF TOKEN="(" THEN
BEGIN "parametic procedure "
DO BEGIN "declar param type"
GGTOKEN;
IF EQU(TOKEN,"SCALAR") THEN FT←#SC
ELSE IF EQU(TOKEN,"VECTOR") THEN FT←#VT
ELSE IF EQU(TOKEN,"ROT") THEN FT←#RT
ELSE IF EQU(TOKEN,"TRANS") THEN FT←#TR
ELSE IF EQU(TOKEN,"FRAME") THEN FT←#FR
ELSE ERROR("need declaration class");
DO BEGIN "declar param"
GGTOKEN;
IF #TOKEN≠UNDECLARED_TYPE
THEN ERROR("function parameter should be undeclared variable");
T1←NEW_RECORD(TEMP);
TEMP:TYPE[T1]←FT;TEMP:NAME[T1]←TOKEN;
TEMP:NEXT[T1]←T;T←T1;NARGS←NARGS+1;GGTOKEN;
END "declar param"
UNTIL TOKEN≠",";
END "declar param type"
UNTIL TOKEN≠";" ;
IF TOKEN ≠ ")" THEN ERROR("need close paren or semicolon here");
END "parametic procedure "
ELSE BEGIN STOKEN←TRUE; SSSS←SSSS[1 TO ∞ - 1]; END;
F←MK_FN(NARGS); FUNCTION:TYPE[F]←OBTYPE; FUNCTION:HEAD[F]←SSSS;
FOR TT←NARGS STEP -1 UNTIL 0 DO
BEGIN
EXPR:TYPE[FUNCTION:PTR[F][TT]←NEW_RECORD(EXPR)]←
FUNCTION:ARGTYPE[F][TT]←TEMP:TYPE[T];
FUNCTION:ARGNAME[F][TT]←TEMP:NAME[T];
T←TEMP:NEXT[T];
END;
GGTOKEN;
IF TOKEN≠"=" THEN ERROR("need = here");
TRE←FNEXPR(F,FBODY,SYMBOLSUSED);
BEGIN RPTR(EXPR) T;
T←NEW_RECORD(EXPR);
EXPR:PTR[T]←TREE:DATA[TRE];
ifc false thenc buggy right now IF OBTYPE=0 THEN
BEGIN EXPR:TYPE[T]←TREE:DTYPE[TRE];
obtype←expr:type[expr:ptr[t]];
function:type[f]←obtype mod #dtype;
function:head[f]←$dtype[obtype mod #dtype]&function:head[f];
END
ELSE
IF (EXPR:TYPE[T]←TREE:DTYPE[TRE])mod #dtype≠OBTYPE
THEN ERROR("function type not same as declared");
elsec expr:type[t]←tree:dtype[tre]; FUNCTION:EXPR[F]←T;
END;
FUNCTION:BODY[F]←FBODY;
S←INSERT(FNAME,#FN); SYMBOL:OBJECT[S]←F;
UNRAVEL_SYMBOLS_USED(SYMBOLSUSED,S);
IFC #DISPL THENC $FNLST←NULL; UPDATE; ENDC
END "declar function";
END "declar function";
END;
PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN STRING SAVTOKEN;
$HELP←0; SAVTOKEN←TOKEN;
GTOKEN;
IF EQU(TOKEN,"FUNCTION") THEN BEGIN FUNCTPROC(OBTYPE,SAVTOKEN); RETURN; END
ELSE STOKEN←TRUE;
DO BEGIN "A"
GTOKEN;
IF #TOKEN ≠UNDECLARED_TYPE
THEN ERROR($SYNMSG[35],$SYNMSG[25])
ELSE BEGIN
CASE OBTYPE OF
BEGIN "CASE"
[#SC] NEW_SC(TOKEN);
[#VT] NEW_VT(TOKEN);
[#RT] NEW_RT(TOKEN);
[#FR] NEW_FR(TOKEN);
[#TR] NEW_TR(TOKEN)
END "CASE";
END;
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
IFC #DISPL THENC UPDATE; ENDC
END;
! used after reading DISTANCE to read VECTOR in declaration statement;
PROCEDURE DIMPROC;
BEGIN
STRING VET;
VET←IDF_READ;
IF EQU(VET,"VECTOR")
THEN DECLPROC(#VT)
ELSE ERROR($SYNMSG[34],NULL);
END;
! parses the instructions
DELETE <variable>,<variable>,..
DELETE (deletes all the variables defined by the user);
PROCEDURE DELETEPROC(BOOLEAN QUIET(FALSE));
BEGIN
STRING VAR;
NOEXPAND ← TRUE;
$HELP←1;
GTOKEN(FALSE);
IF FINAL OR EQU(TOKEN,"ALL")
THEN IF QUIET OR EQU(TOKEN,"ALL") THEN RESET
ELSE BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure all variables are to be deleted? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ABORT1($SEMSG[13]);
END
ELSE BEGIN
STOKEN←TRUE;
$ALLOW←$ALLOW+1;
DO BEGIN "A"
VAR←IDF_READ;
KILLVAR(TOKEN,QUIET);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END;
NOEXPAND ← FALSE;
END;
! reads, for DRIVE instruction, TO|BY <scalar>;
IFC #MOVE THENC
PROCEDURE JT_READ(STRING WHAT,HOW;INTEGER JOINT);
BEGIN "J"
RPTR(TREE) SCAL;
$HELP←22;
SCAL←GTEXPR;
IF TREE:DTYPE[SCAL]≠#SC THEN ABORT1("SCALAR EXPECTED");
OLDSAV("DRIVE",CVS(JOINT)); ! saves for default instructions;
DRIVECODE(WHAT,HOW,JOINT,SCALAR:VALUE[TREE:DATA[SCAL]]);
END "J";
! parses the instruction
DRIVE BJT|YJT (#) TO|BY <scalar>;
PROCEDURE DRIVEPROC;
BEGIN
STRING HOW;
STRING WHAT;INTEGER JOINT;
$HELP←22;
WHAT←IDF_READ;
IF EQU(WHAT,"BJT") OR EQU(WHAT,"YJT")
THEN BEGIN
LPAR_READ; ! reads "(number)";
GTOKEN;
JOINT←INTSCAN(TOKEN,$BRCHR);
IF JOINT<1 OR JOINT>7
THEN ERROR(joint,"joint not existent");
RPAR_READ;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN JT_READ(WHAT,HOW,JOINT)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE ERROR("--→ BJT or YJT ",$SYNMSG[25]);
END;
ENDC
PROCEDURE PRINTPROC;
BEGIN
RPTR(TREE) T;RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)TEMP;
TEMP←TREE:DATA[T←GTEXPR];
SEMICOL_READ;
CASE TREE:DTYPE[T] OF
BEGIN "CASE"
[#SC] OUTSTR( CVGX(SCALAR:VALUE[TEMP])&CRLF);
[#VT] OUTSTR(STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8)&CRLF);
[#RT] OUTSTR(STR_RT(ROT:XF[TEMP])&CRLF);
[#FR] OUTSTR("FRAME "&STR_TR(FRAME:XF[TEMP],1,8)&CRLF);
[#TR] OUTSTR(STR_TR(TRANS:XF[TEMP],1,8)&CRLF)
END "CASE";
END;
PROCEDURE SPRINTPROC;
BEGIN
STRING S;S←NULL;
GTOKEN;
IF TOKEN≠"""" THEN ERROR("need double quote here");
GTOKEN;
WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
SEMICOL_READ;
OUTSTR(S&CRLF);
END;
PROCEDURE EDITPROC(STRING WHAT);
BEGIN
STRING VAR;
NOEXPAND←TRUE;
IF EQU(WHAT,"EDIT")THEN $HELP←37 ELSE $HELP←38;
VAR←IDF_READ;
SEMICOL_READ;
IF EQU(WHAT,"EDIT") THEN EDITCODE(VAR)ELSE RENMCODE(VAR);
END;
PROCEDURE EXITPROC;
BEGIN
$HELP←9;
SEMICOL_READ;
GOTO DONEPOINTY;
END;
! parse procedures: vtrtpart,moveproc,axmovproc;
! moves the frame fr1 along axis by scal;
IFC #MOVE THENC
PROCEDURE ALONGPROC(STRING AXIS,FRA1);
BEGIN
RPTR(TREE) SCAL;RPTR(VECTOR)COMP;RPTR(FRAME)FRAM1,FRAM2;
$HELP←21;
SCAL←GTEXPR;
IF TREE:DTYPE[SCAL]≠#SC THEN ABORT1("SCALAR EXPECTED");
COMP←MK_REC(#VT);
IF AXIS="X" THEN VECTOR:XC[COMP]←SCALAR:VALUE[TREE:DATA[SCAL]]
ELSE IF AXIS="Y" THEN VECTOR:YC[COMP]←SCALAR:VALUE[TREE:DATA[SCAL]]
ELSE VECTOR:ZC[COMP]←SCALAR:VALUE[TREE:DATA[SCAL]];
OLDSAV("MOVE"&AXIS[1 TO 1],FRA1); ! saves for default instructions;
FRAM1←BELONGS(FRA1,#FR);
FRAM2←MK_REC(#FR);
MVFREXP(FRAM1,OPFRVT(COMP,FRAM1,"+"));
END;
! moves the frame along one axis by a scalar;
PROCEDURE AXMOVPROC;
BEGIN
STRING FRA1,AXIS;
$HELP←21;
AXIS←TOKEN[5 TO 5];
FRA1←MVFR_READ;
BY_READ;
ALONGPROC(AXIS,FRA1);
END;
! reads/exec TO <fr>+<vt>{wrt <fr>} or BY <vector>{wrt <fr>};
PROCEDURE BYPROC;
BEGIN
RPTR(FRAME) FRAM1,FRAM2;RPTR(TREE)TEMP;
$HELP←20;
! MOVE<fr>BY<vt> ≡ MOVE<fr>TO⊗+<vt>;
TOKEN←OLDOBJ;
#TOKEN←ID_TYPE;
STOKEN←TRUE;
$CLINR←"+"&$CLINR;
TEMP←GTEXPR;
IF TREE:DTYPE[TEMP]≠#FR THEN ABORT1("frame expected");
FRAM2←TREE:DATA[TEMP];
FRAM1←BELONGS (OLDOBJ,#FR);
MVFREXP(FRAM1,FRAM2);
END;
PROCEDURE TOPROC;
BEGIN
RPTR(FRAME) FRAM1,FRAM2;RPTR(TREE)TEMP;
RPTR(FRAME) ARRAY FDESTS[0:10];
INTEGER NFDEST;
NFDEST←0;
$HELP←20;
DO BEGIN
TEMP←GTEXPR;
IF TREE:DTYPE[TEMP]≠#FR THEN ABORT1("frame expected");
FDESTS[NFDEST←NFDEST+1]←TREE:DATA[TEMP];
IF NFDEST=10 THEN ERROR("Pointy cannot currently handle more than a 9 segment move");
GTOKEN(FALSE);
END UNTIL TOKEN≠",";
FRAM1←BELONGS (OLDOBJ,#FR);
FDESTS[0]←FRAM1;
MVFRSEXP(FDESTS,NFDEST);
END;
! reads move <frame_id> to/by/along <axis> ;
PROCEDURE MOVEPROC;
BEGIN
STRING FR1,AXIS;
$HELP←20;
FR1←IDF_READ;
GTOKEN;
OLDSAV("MOVE",FR1);
IF EQU(TOKEN,"TO") THEN TOPROC
ELSE IF EQU(TOKEN,"BY") THEN BYPROC
ELSE IF EQU(TOKEN,"ALONG")
THEN BEGIN
AXIS←AXIS_READ;
BY_READ;
ALONGPROC(AXIS,FR1);
END
ELSE ERROR($SYNMSG[9],$SYNMSG[25]);
END;
ENDC
! parse procedures: other, readwristproc;
IFC #MOVE THENC
PROCEDURE DEFLT(STRING HOW);
BEGIN
IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
THEN OPENING(OLDCMD,OLDOBJ,HOW)
ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
THEN IF HOW="BY"
THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
ELSE ERROR($SYNMSG[10],$SYNMSG[25])
ELSE IF EQU(OLDCMD,"DRIVE")
THEN JT_READ("BJT",HOW,CVD(OLDOBJ))
ELSE IF EQU(OLDCMD,"MOVE")
THEN IF EQU(HOW,"BY") THEN BYPROC ELSE TOPROC;
END;
ENDC
PROCEDURE ASGMNT(STRING FIRST);
BEGIN "A"
RPTR(TREE)EXPR;
IF EQU(FIRST,"BARM") OR EQU(FIRST,"YARM")
THEN ERROR("You cannot change the value of BARM or YARM");
EXPR←GTEXPR; SEMICOL_READ;
IF EQU(FIRST,"POINTER") THEN
BEGIN IF TREE:DTYPE[EXPR]≠#FR AND TREE:DTYPE[EXPR]≠#TR
THEN ERROR("NEED FRAME EXPRESSION FOR POINTER");
IF ARMFALSE THEN ERROR("ELF cant read arm position:"&ARMERR[ARMFALSE]);
UFX_NODE(F_POINTER,F_BARM);
$ALLOW←$ALLOW+1;
ASGEXP(FIRST,TREE:DATA[EXPR],TREE:DTYPE[EXPR]);
AFX_NODE(F_POINTER,F_ARM,#RGDLK);
$ALLOW←$ALLOW-1; ! for display;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE IF EQU(FIRST,"FIDUCIAL") THEN
BEGIN IF TREE:DTYPE[EXPR]≠#FR AND TREE:DTYPE[EXPR]≠#TR
THEN ERROR("NEED FRAME EXPRESSION FOR FIDUCIAL");
$ALLOW←$ALLOW+1;
F_FID←FR_INSERT(FIRST);
ASGEXP(FIRST,TREE:DATA[EXPR],TREE:DTYPE[EXPR]);
$ALLOW←$ALLOW-1; ! for display;
IFC #DISPL THENC UPDATE;ENDC
END
ELSE ASGEXP(FIRST,TREE:DATA[EXPR],TREE:DTYPE[EXPR]);
END "A";
PROCEDURE OTHER;
BEGIN
STRING FIRST;
$HELP←41;
FIRST←TOKEN;
GTOKEN;
IF TOKEN="←"
THEN ASGMNT(FIRST)
ELSE ERROR($SYNMSG[32],NULL);
END;
IFC #WRIST THENC
PROCEDURE READWRISTPROC;
BEGIN STRING COMMAND,FNAME; RPTR(TREE)EXPR; INTEGER VAL;
VAL←0;FNAME←NULL;
LPAR_READ;
GTOKEN;
COMMAND←TOKEN;
IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
BEGIN
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after CALIB or RENAMEFILE");
IF EQU(COMMAND,"CALIB") THEN
BEGIN
EXPR←GTEXPR;
IF TREE:DTYPE[EXPR]≠#SC THEN ERROR("Need scalar value after CALIB");
VAL←SCALAR:VALUE[TREE:DATA[EXPR]];
END
ELSE FNAME←NAMEFILE;
END
ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
BEGIN
STRING S; S←NULL;
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after SAVERAWDATA");
GTOKEN;
IF TOKEN≠"""" THEN ERROR("need double quote here");
GTOKEN;
WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
FNAME←S;
END;
RPAR_READ;
GTOKEN(FALSE);
IF NOT FINAL THEN
ERROR("This is an incomplete instruction")
ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
ERROR("ERROR in reading wrist",$WRMSG[VAL]);
END;
ENDC
! parse procedures: parking,readproc,renmproc,writeproc,unfixproc;
IFC #MOVE THENC
PROCEDURE PARKING;
BEGIN
RPTR(FRAME)ARRAY FFR[0:1];
STRING PAR; $HELP←25 ; PAR←TOKEN; SEMICOL_READ;
IF PAR="BPARK" or par="PARK" THEN BEGIN FFR[0]←F_BARM; FFR[1]←F_BPARK;
GOARM(FFR); END;
IF PAR="PARK" OR PAR="YPARK" THEN BEGIN FFR[0]←F_YARM; FFR[1]←F_YPARK;
GOARM(FFR); END;
$FRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
ENDC
IFC #OUTPT THENC
PROCEDURE READPROC(BOOLEAN ECHO(TRUE));
BEGIN
STRING FILE;
$HELP←34;
FILE←"DECLAR.AL"; ! default value;
GTOKEN(FALSE);
IF NOT FINAL
THEN BEGIN
STOKEN←TRUE;FILE←NAMEFILE;SEMICOL_READ;
END;
READCODE(FILE,ECHO);
END;
PROCEDURE WRITEPROC(STRING PDEFPR(NULL));
BEGIN "A"
STRING FILE;
INTEGER DTYPE;
RPTR(SYMBOL) ELEMENT;
ELEMENT ← NULL_RECORD;
$HELP←31;
NOEXPAND←TRUE;
FILE←$ALFL; ! default values;
GTOKEN(FALSE);
IF NOT FINAL
THEN CASE #TOKEN OF
α
[RES_TYPE]
IF EQU(TOKEN,"INTO") THEN STOKEN←TRUE
ELSE IF ¬EQU(TOKEN,"ALL") THEN ERROR("Can't use "&TOKEN&
" as argument to be saved in a write statement");
[ID_TYPE]
α ELEMENT←TOKENPTR; DTYPE←TOKENINDEX; β;
ELSE ERROR("Can't write out the value of "&TOKEN)
β;
GTOKEN(FALSE);
IF NOT FINAL
THEN IF ¬EQU(TOKEN,"INTO") THEN
ERROR("Need INTO here before putting in file name, but you have got "&token)
ELSE FILE←NAMEFILE;
NOEXPAND ← FALSE;
WRITECODE(FILE,ELEMENT,DTYPE,PDEFPR);
IFC #DISPL THENC UPDATE;ENDC
END "A";
ENDC
PROCEDURE UNFIXPROC;
BEGIN
STRING FR1,FR2;
$HELP←15;
FR1←IDF_READ;
FR2←FROMPART;
UNFIXCODE(FR1,FR2);
END;
! parse procedures :notavailproc,displayproc,nodisplayproc,readlisp,stoplispproc;
PROCEDURE NOTAVAILPROC;
BEGIN
PRINT(TOKEN & " " &#VERSION);
OUTSTR("Will flush this statement"&crlf);
DO GTOKEN(FALSE) UNTIL FINAL;
END;
IFC #DISPL THENC
PROCEDURE REDISPLAYPROC;
BEGIN
SEMICOL_READ;
$ALLOW←0;
TDISPLAY←0;
$SCLST←NULL;
UPDATE;
END;
PROCEDURE NODISPLAYPROC;
BEGIN
! SUPPRESS DISPLAY;
SEMICOL_READ;
TDISPLAY←-1;
UPDATE;
END;
PROCEDURE DISPLAYPROC;
BEGIN
INTEGER TT;
STRING DDSS,S77;
RPTR(SYMBOL) TMAC;
NOEXPAND ← TRUE;
GTOKEN;
TMAC ← CHECK(TOKEN,#MC);
IF TMAC NEQ NULL_RECORD
THEN BEGIN
DDSS ← MACDYS(TMAC);
IF TDISPLAY = 0
THEN BEGIN
OUTDPW(DDSS,-3,-2);
PRINT("YOU CAN RETURN TO DISPLAY TYPING ANY CARACTER...");
S77 ← INCHWL;
REDISPLAYPROC;
END
ELSE OUTDPW(DDSS,-3,-2);
NOEXPAND ← FALSE;
END
ELSE BEGIN
FOR TT←#MIN STEP 1 UNTIL #MAX DO
IF EQU(TOKEN,$DTYPE[TT]) OR EQU(TOKEN,$DTYPE[TT]&"S") THEN DONE;
IF TT≤#MAX THEN $DISPLAYLIST[TT]←NULL
ELSE ERROR("No such data type or identifier: "&TOKEN&CRLF);
SEMICOL_READ;
TDISPLAY←TT;
UPDATE;
END;
END;
ENDC
PROCEDURE READMESSPROC;
BEGIN
SEMICOL_READ;
PUSHDEVSTACK;
DEVICE←MESSAGE_X;
END;
PROCEDURE STOPMESSPROC;
BEGIN
SEMICOL_READ;
$CLNE←$CLINR←NULL;
POPDEVSTACK;
END;
! parse;
define tokencodes "[][]" =[
ZZ("↓", downarrow_x, #factor)
ZZ("α", ALPHA_X, #FACTOR)
ZZ("→", backarrow_X, #TERM)
ZZ("$", DOLLAR_X, #FACTOR)
ZZ(["("], LPAREN_X, #FACTOR)
ZZ("*", times_X, #TERM)
ZZ("+", Plus_X, #EXP)
ZZ("-", minus_X, #EXP)
ZZ(".", dot_X, #TERM)
ZZ("/", divide_X, #TERM)
XX(TRUE, AFFIX, AFFIXPROC)
XX(TRUE, ALL, NOTAVAILPROC)
ZZ("ARCCOSINE", ACOSINE_X, #FACTOR)
ZZ("ARCSINE", ASINE_X,#FACTOR)
ZZ("ATAN2", ATAN2_X,#FACTOR)
ZZ("AXIS", AXIS_X, #FACTOR)
XX(#DEBUG, BAIL, BAILCALL)
XX(#MOVE, BPARK, PARKING )
XX(#MOVE, BY, DEFLT("BY"))
XX(#MOVE, CENTER, CENTERPROC)
XX(TRUE, CLOSE, CLOSEPROC)
XX(TRUE, CLOSE_FILES, FCLPROC)
XX(TRUE, COMMENT, [READTO(";")])
ZZ("CONSTRUCT", CONSTRUCT_X, #FACTOR)
XX(TRUE, COPY, COPYPROC)
ZZ("COS", COSINE_X,#FACTOR)
XX(TRUE, DEFINE, DEFINEPROC)
XX(TRUE, DELETE, DELETEPROC)
XX(#DISPL, DISPLAY, DISPLAYPROC)
XX(TRUE, DISTANCE, DIMPROC)
ZZ("DIV", DIV_X, #TERM)
XX(#MOVE, DRIVE, DRIVEPROC)
XX(TRUE, EDIT, EDITPROC("EDIT"))
ZZ("EVAL", EVAL_X, #FACTOR)
XX(TRUE, EXIT, EXITPROC)
XX(TRUE, FCONSTRUCT, FCONSTRUCTPROC)
XXZZ(TRUE, FRAME, DECLPROC(#FR), FRAME_X, #FACTOR)
XX(TRUE, FUNCTION, FUNCTPROC)
ZZ("INT", INT_X, #FACTOR)
XX(TRUE, INTO, NOTAVAILPROC)
ZZ("MAX", MAX_X, #TERM)
XX(TRUE, MERGE, NOTAVAILPROC)
ZZ("MIN", MIN_X, #TERM)
ZZ("MOD", MOD_X, #TERM)
XX(#MOVE, MOVE, MOVEPROC)
XX(#MOVE, MOVEX, AXMOVPROC)
XX(#MOVE, MOVEY, AXMOVPROC)
XX(#MOVE, MOVEZ, AXMOVPROC)
XX(#DISPL, NODISPLAY, NODISPLAYPROC)
XX(#MOVE, OPEN, OPCLPROC(TOKEN))
ZZ("ORIENT", ORIENT_X, #FACTOR)
XX(#MOVE, PARK, PARKING)
ZZ("POS", POS_X, #FACTOR)
XX(TRUE, PRINT, PRINTPROC)
XX(TRUE, PROMPT, PROMPTPROC)
XX(#OUTPT, PWRITE, WRITEPROC("PRETTY"))
XX(TRUE, QDELETE,DELETEPROC(TRUE))
XX(#OUTPT, QREAD, READPROC(FALSE))
XX(#OUTPT, READ, READPROC)
XX(TRUE, READMESSAGE, READMESSPROC)
XX(#WRIST, READWRIST, READWRISTPROC)
XX(#DISPL, REDISPLAY, REDISPLAYPROC)
ZZ("REL", rel_X, #TERM)
XX(TRUE, RENAME, EDITPROC("RENAME"))
XXZZ(TRUE, ROT, DECLPROC(#RT), ROT_X, #FACTOR)
XX(TRUE, SCALAR, DECLPROC(#SC))
ZZ("SIN", SINE_X, #FACTOR)
XX(TRUE, SPRINT, SPRINTPROC)
ZZ("SQRT", SQRT_X, #FACTOR)
XX(TRUE, STOPMESSAGE, STOPMESSPROC)
XX(TRUE, SUBTREE, NOTAVAILPROC)
XX(#MOVE, TO, DEFLT("TO"))
XXZZ(TRUE, TRANS, DECLPROC(#TR), TRANS_X, #FACTOR)
XX(TRUE, UNFIX, UNFIXPROC)
ZZ("UNIT", UNIT_X, #FACTOR)
XXZZ(TRUE, VECTOR, DECLPROC(#VT), VECTOR_X, #FACTOR)
XX(#OUTPT, WRITE, WRITEPROC)
ZZ("WRT", WRT_X, #TERM)
XX(#MOVE, YPARK, PARKING)
ZZ("↑", UPARROW_X, #FACTOR)
ZZ("|", MAGNITUDE_X, #FACTOR)
];
define res_count = 0;
redefine zz(arg1,arg2,arg3)"[][]"=[redefine res_count=res_count+1;];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=[redefine res_count=res_count+1;];
redefine xx(#flag, str, oper)"[][]"=[redefine res_count=res_count+1;];
tokencodes;
redefine xx(#flag,str,oper)"[][]" = ["str", ];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=["str",];
redefine zz(arg1,arg2,arg3)"[][]"=[arg1,];
! array containing all the reserved words and operators;
preset_array( rescode , tokencodes , string , 1 , res_count);
define xx_count=0;
redefine xx(#flag,str,oper)"[][]"=[
redefine xx_count=xx_count+1;
xx_count*(ROT_X+1)*#DTYPE, ];
redefine zz(arg1,arg2,arg3)= [arg2*#dtype+arg3,];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=[
redefine xx_count=xx_count+1;
(xx_count*(rot_x+1)+arg1)*#dtype+arg2, ];
preset_array(tcodes, tokencodes, integer, 1, res_count);
internal INTEGER PROCEDURE decSTR(string VAL);
BEGIN INTEGER L,M,U,I1,I2; STRING S1,S2;
L←1; U←res_count;
DO begin M←(U+L)/2;
IF EQU(S1←rescode[M],S2←val) THEN
begin res_class←TCODES[M] DIV( (ROT_X+1)*#DTYPE);
tokenclass←tcodeS[m] mod #dtype;
tokenindex← (tcodeS[m] div #dtype) mod (rot_x+1);
RETURN(M);
end
ELSE DO begin I1←LOP(S1); I2←LOP(S2); end until i1≠i2;
if i1>i2 then U←M-1 ELSE L←M+1;
end UNTIL L>U;
res_class←tokenclass←tokenindex←0;
RETURN(0);
END;
RECURSIVE PROCEDURE PARSE;
BEGIN "PARSE"
NOEXPAND←FALSE;
GTOKEN; ! reads first token;
STBEGIN←FALSE;
IF "A"≤ TOKEN ≤"Z" THEN
CASE res_class of
BEGIN "CASE"
redefine xx(#flag, str,oper)"[][]"=[
ifc #flag thenc ; oper elsec ; notavailproc endc];
redefine xxzz(#flag, str,oper,arg1,arg2)"[][]"=[
; oper ];
redefine zz(arg1,arg2,arg3)"[][]"=[];
OTHER
tokencodes
END "CASE"
ELSE IF TOKEN=";" OR TOKEN=NULL THEN BEGIN END
ELSE IF TOKEN="?" THEN IFC #HELP
THENC HELPREQUEST
ELSEC PRINT(#VERSION) ENDC
ELSE IFC #ARROW THENC
IF TOKEN="↑"
THEN BEGIN
$ARROW←$ARROW+20;
UPDATE;
END
ELSE IF TOKEN="↓"
THEN BEGIN
$ARROW←$ARROW-20;
UPDATE;
END
ELSE IF #TOKEN=INT_TYPE
THEN BEGIN
INTEGER NUM;
NUM←INTSCAN(TOKEN,$BRCHR);
GTOKEN;
IF TOKEN="↓" THEN $ARROW←$ARROW-NUM*20
ELSE IF TOKEN="↑" THEN $ARROW←$ARROW+NUM*20
ELSE ERROR($SYNMSG[32],NULL);
UPDATE;
END
ELSE ENDC
BEGIN
$HELP←8;
ERROR($SYNMSG[31],NULL);
END
END "PARSE";
! main program;
INTEGER HOUR; STRING $HOUR;
SIMPLE INTEGER PROCEDURE GETHOUR;
RETURN( CALL(0,"TIMER") DIV 216000);
IFC #DISPL THENC INIDPY;ENDC
HOUR←GETHOUR;
IF HOUR < 12 THEN $HOUR←"Morning" ELSE IF HOUR < 17 THEN $HOUR←"Afternoon"
ELSE $HOUR←"Evening";
PRINT("Hello..."&$USERNAME&"...Good "&$HOUR&" and welcome to POINTY.
* indicates POINTY is waiting for a new command
****>>> POINTY is waiting for the rest of current command
INPUT command no longer valid - just use the frame you want.
<ESCAPE> I will terminate current statement and flush all typeahead.
");
IFC #HELP THENC PRINT("Type ? for help.",CRLF);ENDC
IFC #OUTPT THENC
BACKUP; $HOUR←INCHSL(HOUR);
IF $HOUR[∞ FOR 1]≠"Q" THEN TTYSAVE; STOKEN←FALSE; ENDC
! allows opening a file to save ;
$GTEXPR←TRUE; READARM(F_BARM); $GTEXPR←FALSE;
IFC #DISPL THENC UPDATE;ENDC
intmap(15,esc_I,0); ! set mapping for interrupt handler;
$ESC_I←false; ENABLE(15);
WHILE TRUE DO
BEGIN
STBEGIN←TRUE; ! waiting for a new command;
PARSE; ! parses the instruction;
IF $ESC_I THEN
BEGIN
MTYDEVSTACK;
PRINT("
<ESCAPE> I termination
");
END;
MAINL: STOKEN←FALSE;
END;
DONEPOINTY:
BRK_N; ! clear the screen and normalize it;
HOUR←GETHOUR;
IF HOUR<5 THEN $HOUR←"please get some sleep, you've been working late"
ELSE IF HOUR <15 THEN $HOUR←"have a nice day"
ELSE IF HOUR <20 THEN $HOUR←"have a nice evening"
ELSE $HOUR←"good night, and pleasant dreams";
PRINT("Bye,bye, ..."&$USERNAME&"... "&$HOUR,CRLF);
LODED("dea elf"&CRLF&CRLF); ! to avoid forgetting to deassign;